home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops ƒ / Files < prev    next >
Text File  |  1993-02-03  |  14KB  |  570 lines
  1. \ Files  - file object and loader
  2.  
  3. cl1                        \ In case we're reloading
  4. ' cl1    -> abortVec
  5.     0    -> quitvec
  6.  
  7.  
  8.     0    value        SFDlgHook    \ Used in std file calls.  If non-zero,
  9.                                 \  points to the proc to be called while
  10.                                 \  the std file dialog is up.
  11.  
  12. -39        constant    EOF            \ EOF error return
  13. -43        constant    FNF            \ File not found ditto
  14.  
  15. -300     constant    FILE-MARK
  16. \ Marks the start of a loaded file - we plant some useful info there.
  17. \ We put the file name in the dic as if it's a definition name, but use
  18. \ file-mark as a "handler code".  Then after that we put the useful info.
  19. \ See extrasMod.
  20.  
  21. false    value    ASYNCH?
  22. false    value    ENDLOAD?
  23. false    value    LOG?
  24.  
  25.     0    value    OPEN_CNT
  26.     0    value    CLOSE_ERR_CNT
  27.  
  28. forward    CREATE_LOG
  29. forward    WRITE_LOG
  30.  
  31.     string    $LG1
  32.     string    $LG2
  33.  
  34.  
  35. : ASYNCH    true -> asynch?  ;
  36.  
  37. : IOWAIT    BEGIN  busy  0EXIT  pause  AGAIN   ;
  38.  
  39. : (ASY)        \ ( fcb -- )  Sets up for a low-level asynchronous read or write.
  40.     IOwait
  41.     -> busy  setCP  ;
  42.  
  43.  
  44. : VOLNAME?  {  str -- b } 
  45.     reset: str
  46.     58 chsearch: str
  47.     NIF  false  EXIT  THEN
  48.     lim: str  2 >=  ;
  49.  
  50.  
  51. : -ECHO        false -> echo?  ;
  52. : +ECHO        true  -> echo?  ;
  53.  
  54. forward  OPEN_WITH_PATHS
  55.  
  56. false    value    USE_PATHS?
  57.  
  58. : HFS?    $ 3f6 w@x  0>  ;
  59.  
  60. variable    MyDocName    28 allot
  61.  
  62. : MyDoc        \ ( -- addr len )
  63.     MyDocName  count  ;
  64.  
  65. \ Standard file package support
  66.  
  67. : SFLOC  {  \ ht wd -- x:y }
  68.         \ Computes screen coordinates for top left of
  69.         \ SF dialog box.  Centers the box horizontally, and a bit above
  70.         \ the center vertically.
  71.     screenbits  -> ht  -> wd  2drop
  72.     ht 3 /  80 -  0 max  -> ht
  73.     wd 2/  170 -  0 max  -> wd
  74.     wd ht pack  ;
  75.  
  76.  
  77. :class     SFrec    super{ object } 
  78.  
  79.     int            Good
  80.     var            fType
  81.     int            vRefNum
  82.     int            Version
  83. 64    bytes        Filename        \ max size is 64
  84. 4    ordered-col    fTypes            \ list of filetypes
  85.  
  86. :m GetVRefNum:    get: vRefNum   ;m
  87. :m GetName:        addr: FileName   ;m
  88.  
  89. :m CALL:        \ ( routine# -- bool )  Calls a Standard File Package routine.
  90.     SFDlgHook  ^base  rot makeint  trap$ A9EA
  91.     get: good  ;m
  92.  
  93. :m STDGET:  ( type0 ...typeN ) {  #types -- bool } 
  94.     clear: fTypes  #types  0>
  95.     IF    #types 0  DO  add: fTypes  LOOP  THEN
  96.     SFloc  0 0  #types makeint  ixAddr: fTypes
  97.     2 call: self  ;m
  98.  
  99. :m STDPUT:  {  pAddr pLen nAddr nLen -- bool } 
  100.     pAddr pLen pad place
  101.     SFloc  pad  nAddr nLen  str255
  102.     1 call: self  ;m
  103.  
  104. ;class 
  105.  
  106.  
  107. objHandle    SFHDL
  108. objPtr        SFOBJ   class_is  SFrec
  109.  
  110.  
  111. \ DO_OPEN does the hard work for OPEN: file.  First, if either the DirID
  112. \ or the vol ref# is non-zero, we rashly assume we know which folder we
  113. \ want, and just do an open.  We also do that if we're not running under HFS.
  114. \ Then, if we get through to here, we need to look at the paths.  But wait!
  115. \ First, we check the default folder by just doing a plain open anyway!  If
  116. \ this fails with a "file not found", we call ?USE_PATHS which either does
  117. \ nothing (if we're not using a path designator file), or calls our PATHSMOD
  118. \ module to look at a PD file and try using those paths to find the wanted
  119. \ file.
  120.  
  121. : DO_OPEN  {  fcb mode -- rc } 
  122.     1 ++> open_cnt
  123.     ^base 48 + @                    \ DirID
  124.     ^base 22 + w@                    \ vol ref#
  125.     or  HFS? not  or                \ Either non-zero, or not HFS?
  126.     use_paths? not  or                \ Or paths disabled?
  127.     IF                                \ Yes: just do a normal open, and get out.
  128.         fcb mode (open)  EXIT
  129.     THEN
  130.                                     \ Maybe use HFS paths:
  131.     fcb mode (open) dup  0EXIT        \ Try default folder first
  132.                                     \ -- out if we found it
  133.     dup FNF <>  ?EXIT                \ If err wasn't FNF, get out
  134.     use_paths?  0EXIT                \ If paths disabled, out with FNF
  135.     drop  fcb mode open_with_paths  ;
  136.  
  137.  
  138.  
  139. :class   FILE    super{ object }
  140.  
  141. 134    bytes        FCB            \ max parameter block (108 but for hgetvinfo)
  142.     object        FSSpec        \ Really just a label - FSSpec record starts here
  143.     int            FSvRefNum
  144.     var            FSDirID
  145. 64    bytes        FileName
  146.  
  147.  
  148. :m CLEAR:        \ Clears the fcb, except for the filename.
  149.     ^base  18 erase  ^base 22 +  112 erase  ;m
  150.  
  151. :m SETNAMEPTR:    \ Sets filename pointer in the FCB.
  152.     ^base 140 +  ^base !fptr  ;m
  153.  
  154. :m NAME:        \ ( addr len -- )  Assigns file name to fcb.  Rest cleared.
  155.     setNamePtr: self  clear: self
  156.     ^base 140 +  >r                    \ Addr of filename (at end of fcb)
  157.     r@  64 blanks
  158.     ( addr len )  64 min  r>  >str255  drop  ;m
  159.  
  160. :m SETDIRID:    \ ( dirid -- )  Sets the DirID for the fcb
  161.     ^base 48 +  !  ;m
  162.  
  163. :m GETDIRID:    \ ( -- dirid )  Gets the DirID for the fcb
  164.     ^base 48 +  @  ;m
  165.  
  166. :m GETFREF:    \ ( -- fref )  Gets the file ref number.
  167.     ^base 24 +  w@  ;m
  168.  
  169. :m SETFREF:
  170.     ^base 24 +  w!  ;m
  171.  
  172. :m SETVREF:    \ ( vref# -- )  Sets the volRefNum for the fcb
  173.     ^base 22 +  w!  ;m
  174.  
  175. :m GETVREF:    \ ( -- vref# )  Gets the volRefNum for the fcb
  176.     ^base 22 +  w@  ;m
  177.  
  178.  
  179. :m CLOSE:    \ ( -- rc )   Needs to clear the file RefNum field,
  180.             \ as advised in Mac Tech note # 102.  In fact we clear
  181.             \ the whole fcb except the name and Vref, so we can reuse
  182.             \ the fcb for a subsequent operation without the extra info
  183.             \ left by read and write calls being interpreted as HFS info.
  184.             
  185.     ^base  (close)  getVref: self  clear: self  setVref: self
  186.     dup if  1 ++> close_err_cnt  else  -1 ++> open_cnt  then  ;m
  187.  
  188.  
  189. :m OPEN:    \ ( -- rc )
  190.     ^base 0 do_open  ;m
  191.  
  192. :m OPENREADONLY:
  193.     ^base 1 do_open  ;m
  194.  
  195.  
  196. :m NEW:    ^base  (make)  ;m
  197.  
  198. :m DELETE:    ^base (delete)  ;m
  199.  
  200. :m MOVETO:    \ ( byteoffset -- rc )  Positions relative to start of file
  201.     ^base 1 rot  (lseek)  ;m
  202.  
  203. :m POS:        \ ( -- byteoffset )
  204.     ^base  $ 2E +  @  ;m
  205.  
  206. :m SETEOF:    \ ( pos -- rc )  Sets end-of-file to absolute byte position
  207.     ^base 28 + !  ^base fdos$ a012  ;m
  208.  
  209. :m CREATE:  { \ volID -- } 
  210.             \ Opens and resets file or creates new if not present.
  211.     1 ++> open_cnt
  212.     ^base 0 (open)                \ Attempt to open - don't use paths
  213.     ?dup
  214.     IF    dup FNF =
  215.         IF    drop
  216.             new: self  ?dup NIF  ^base 0 (open)  THEN
  217.         THEN
  218.     ELSE
  219.         0 setEOF: self
  220.     THEN  ;m
  221.  
  222. :m LAST:        \ Positions to end of file.
  223.     big# moveto: self  drop  ;m
  224.  
  225. :m SIZE:        \ ( -- #bytes )  Returns logical eof for file currently open
  226.     ^base fdos$ a011  drop ^base 28 + @  ;m
  227.  
  228. :m BYTESREAD:    \ ( -- n )  Returns actual bytes read.
  229.     ^base 40 + @  ;m
  230.  
  231. :m FCB:  ( -- fcb )     ^base  ;m
  232.  
  233. :m RESULT:    \ ( -- rc )  Returns the last I/O result code.
  234.     ^base 16 + w@  ;m
  235.  
  236. :m MODE:        \ ( posMode -- )  Sets position mode
  237.     ^base 44 + w!  ;m
  238.  
  239.  
  240. :m WAIT:    \ ( -- rc )  Waits for asynch I/O on this file to finish.
  241.     BEGIN    ^base busy =
  242.         NIF   ^base 16 + w@x  EXIT  THEN
  243.         pause
  244.     AGAIN  ;m
  245.  
  246. :m ?WAIT:    \ ( rc1 -- rc2 )
  247.     asynch?
  248.     NIF        drop  wait: self
  249.     ELSE    false -> asynch?
  250.     THEN   ;m
  251.  
  252.  
  253. :m READ:        \ ( addr length -- rc )
  254.     0 mode: self ^base swap rot
  255.     ^base (asy)  (read)  ?wait: self  ;m
  256.  
  257. :m READLINE:    \ ( addr maxLen -- rc )  Reads terminating with CR
  258.     $ 0D80 mode: self  ^base  swap rot
  259.     ^base (asy)  (read)  ?wait: self  ;m
  260.  
  261. :m WRITE:        \ ( addr length -- rc )
  262.     ^base  swap rot
  263.     ^base (asy)  (write)  ?wait: self  ;m
  264.  
  265. :m SETNAME:        \ Gets name from input stream, and assigns to fcb.
  266.     & "  parse-word  name: self  ;m
  267.  
  268. :m GETNAME:        \ ( -- addr len )  Returns filename
  269.     addr: fileName  count  ;m
  270.  
  271. :m PRINT:        \ Prints the filename.
  272.     getName: self  type  ;m
  273.  
  274. :m GETFILEINFO:        \ ( -- rc )  Fills the parameter block with file info
  275.     ^base fdos$ A20C  ;m
  276.  
  277. :m SETFILEINFO:        \ ( -- rc )
  278.     ^base fdos$ A20D  ;m
  279.  
  280. :m SET:  { ftyp sig -- }            \ Sets file type, signature.
  281.     getDirID: self                    \ Save DirID
  282.     0 setDirID: self                \ and clear it (otherwise we'll get
  283.     getFileInfo: self  drop            \  "file not found")
  284.     sig  ^base  $ 24 +  !            \ Set signature
  285.     ftyp ^base  $ 20 +  !            \ Set type
  286.     0 setDirID: self
  287.     setFileInfo: self  drop
  288.     setDirID: self  ;m                \ Restore DirID
  289.  
  290.  
  291. :m DRIVE:    \ ( drive# -- )  set default drive to drive#
  292.     clear: self  setVRef: self  ^base fdos$ a015
  293.     ?error 165  ;m
  294.  
  295.  
  296. :m ACCEPT:  { addr len \ #chrs eof? -- #chrs eof? }     \ ACCEPTs from disk.
  297.     echo? IF  addr len erase  THEN        \ So the typed line is OK
  298.     addr len  readLine: self  -> eof?
  299.     bytesRead: self  eof? NIF  1-  THEN  -> #chrs
  300.     #chrs 0=  eof? and  IF  0  true  EXIT  THEN
  301.     addr #chrs +  c@  13 <>
  302.     IF                                \ Overlength line. Probably a comment.
  303.         BEGIN                        \ Gobble to CR or EOF
  304.             pad 100  readLine: self  -> eof?
  305.             eof?
  306.             IF        true
  307.             ELSE    pad  bytesRead: self  1-  +  c@ 13 =
  308.             THEN
  309.         UNTIL
  310.     THEN
  311.     echo?
  312.     IF    addr len type  cr  THEN
  313.     BEGIN                            \ Loop to convert tabs to blanks
  314.         addr len  9 scan  -> len  -> addr
  315.         len
  316.     WHILE
  317.         bl addr c!
  318.     REPEAT
  319.     #chrs  false   ;m
  320.  
  321.  
  322. :m RENAME: { taddr tlen -- rc } 
  323.     taddr tlen str255
  324.     ^base 28 + !  ^base fdos$ A00B  ;m
  325.  
  326.  
  327. :m GETTYPE:        \ ( -- type )
  328.     ^base 32 + @  ;m
  329.  
  330. :m FLUSHVOL:
  331.     ^base fdos$ A013  drop  ;m
  332.  
  333.  
  334. :m CLASSINIT:        clear: self  setNamePtr: self  ;m
  335.  
  336.  
  337. \ Standard file package calls.  If the value SFDlgHook is non-zero, we take it as the
  338. \ address of a dialog hook routine.
  339.  
  340. private
  341.  
  342. :m SFPCALL:        \ ( various get? -- b )  Calls a Standard File Package routine
  343.     classinit: self                        \ Make sure name pointer is right
  344.     ['] SFrec  newObj: SFhdl
  345.     obj: SFhdl  -> SFobj
  346.     IF    stdGet: SFobj  ELSE  stdPut: SFobj  THEN
  347.     IF    getVRefNum: SFobj  clear: self  setVref: self
  348.         getName: SFobj  count  addr: fileName  place
  349.         true
  350.     ELSE
  351.         false
  352.     THEN
  353.     release: SFhdl  ;m
  354.  
  355. public
  356.  
  357. :m STDGET:    \ ( type0 ...typeN #types -- bool )
  358.     true sfpCall: self  ;m
  359.  
  360. :m STDPUT:    \ ( pAddr pLen nAddr nLen -- bool )
  361.     false sfpCall: self  ;m
  362.  
  363. ;class 
  364.  
  365.  
  366. ' fFcb  set_to_class  file            \ Make fFcb a FILE objPtr
  367. 6    fFcb 8 -    w!
  368. ' file    fFcb 6 -    reloc!
  369. -6    fFcb 2 -    w!
  370.  
  371.  
  372. \ GetDirID returns the dirID of the last directory opened by a
  373. \ standard file call.
  374.  
  375. : GETDIRID    $ 398 @  ;
  376.  
  377.  
  378. \ FileList keeps a stack of open load files for nested loads.
  379.  
  380. objPtr    TOPFILE  class_is  file
  381.  
  382.  
  383. :class     FILELIST  super{ handleArray } 
  384.  
  385. :m DROP:
  386.     top: super                        \ Give error if empty
  387.     close: topFile  drop
  388.     drop: super
  389.     size: super  NIF  nilP  ELSE  obj: self  THEN
  390.     -> topFile
  391.     false -> endload?   ;m
  392.  
  393. :m PUSHNEW:        \ Adds a new file to the stack
  394.     ['] file  pushNewObj: self
  395.     false -> endload?
  396.     obj: self  -> topFile            \ Note this locks the file object
  397.                                     \ -- this is what we want.
  398.     0 setVref: topFile   ;m
  399.  
  400. :m CLEAR:    \ Removes all currently open files
  401.     false -> endload?
  402.     get: size  0EXIT
  403.     type# 180  ( File stack: )  cr  top: self
  404.     get: size  FOR
  405.         print: topFile  cr  drop: self
  406.     NEXT  ;m
  407.  
  408. ;class 
  409.  
  410.  
  411. 10    fileList    LOADFILE
  412.  
  413. 0    value        FILESTART_DP
  414. 0    value        CNT
  415. 0    value        SvLATEST
  416.  
  417.  
  418. : LOGIT
  419.     state  0EXIT                    \ Out if we're not compiling
  420.     here filestart_DP -  pad w!
  421.     pos: topFile  src-len -
  422.     pad 2+  !
  423.     pad 6  add: $lg1  ;
  424.  
  425.  
  426. 0    value    LASTPOS
  427.  
  428. : LOGCR
  429.     state  0EXIT
  430.     here lastPos <=  ?EXIT
  431.     here -> lastPos
  432.     pad 14 erase
  433.     here filestart_DP -  pad w!
  434.     latest svLatest <> IF  true pad 4+ c!  latest -> svLatest  THEN
  435.     pad 14  add: $lg2  ;
  436.  
  437.  
  438. : (FREFILL)        \ ( -- flag )  Does a refill from a file.
  439.     echo?
  440.     IF        ?pause
  441.     ELSE    cnt NIF  ?pause  20 -> cnt  else  1 --> cnt  THEN
  442.     THEN
  443.     log? IF  logCR  THEN
  444.     tib tibLen  accept: topfile  ( #chrs eof? ) -> endload?  #tib !
  445.     set_source  endload? 0=  ;
  446.  
  447. ' (Frefill) -> Frefill
  448.  
  449.  
  450. : (LD)
  451.     begin    endload?  if  false -> endload?  exit  then
  452.     topfile -> source-ID  (Frefill)  if  interpret  then
  453.         state not  echo? and  if  ok  then
  454.     again  ;
  455.  
  456.  
  457. false    value    DO_CR?
  458.  
  459. : LOADTOP  {  \ svCurs svHere -- } 
  460.                 \ Interprets the file as a Mops source file.
  461.     openReadOnly: topfile
  462.     IF ( error )  getName: topfile  type  132 die  THEN
  463.     curs -> svCurs  -curs
  464.     cr
  465.     size: loadFile 2*  spaces  type# 173 ( Loading: ) 
  466.     getName: topfile  type
  467.     log? IF
  468.         create_log  ['] logit  -> logVec
  469.         0 -> svLatest
  470.     THEN
  471.     here -> svHere
  472.     false -> endload?  false -> do_cr?
  473.     (ld)
  474.     ['] null  -> logvec
  475.     close: topfile  drop  log? IF write_log  THEN
  476.     do_cr?
  477.     IF  cr  size: loadFile 2*  ELSE  2  THEN  spaces  true -> do_cr?
  478.     here svHere -  ." Size: "  .
  479.     depth IF  cr msg# 75  THEN        \ Warning - stack not empty after load
  480.     svCurs -> curs  ;
  481.  
  482.  
  483. : ENDLOAD        true -> endload?  0 -> src-len  ;
  484.  
  485.  
  486. \ Nesting loader.  Usage: // filename
  487.  
  488. : //  {  \ svcurs addr len -- } 
  489.     pushNew: loadFile  setName: topFile
  490.     getName: topFile  -> len  -> addr
  491.     addr pad len cmove  bl pad len + c!    \ Append a blank to the file name
  492.     pad len 1+ sHdr                        \ and enter into dic so we can SHOW it
  493.     file-mark w,
  494.     0 ,  0 w,  0 ,                        \ No dir, no log, no date
  495.     loadTop
  496.     drop: loadFile  ;
  497.  
  498.  
  499. \        ======= Module support ========
  500.  
  501. : NOMOD        -1 -> modbase  -1 -> MBcomp  0 -> CompMod  ;
  502.  
  503.  
  504. : LDFROMMOD {  newModbase \ svModbase svMBcomp -- } 
  505.         \ Load from a module.  We save and restore the current
  506.         \ modbase and MBcomp value, in case the load changes them.
  507.  
  508.     modbase -> svModbase  MBcomp -> svMBcomp
  509.     newModbase  dup  -> modbase  -> MBcomp
  510.     loadtop
  511.     svModbase -> modbase  svMBcomp -> MBcomp  ;
  512.  
  513.  
  514. \        ========== Save ==========
  515.  
  516. 'type COM    constant    SAVETYPE    \ file type = 'COM '
  517. 'type MOPS    constant    SAVESIG        \ Signature = 'MOPS'
  518.  
  519. : SAVE_THIS    \ ( -- addr len )  Defines what to save
  520.     ['] latest  here over -  ;
  521.  
  522.  
  523. \ PURGE gets rid of all loaded modules.  It is defined in the file Modules.
  524. \ SAVE needs to call it first, so that saved dic images don't appear to
  525. \ reference loaded modules which aren't really loaded.  So that we can call
  526. \ SAVE before Modules is loaded, we make PURGE a vector rather than a
  527. \ forward definition.
  528.  
  529. ' null    vect    PURGE
  530.  
  531.  
  532. : (SAVE)  {  \ savdp savlatest -- rc } 
  533.     create: ffcb  ?error 107
  534.     dp -> savdp  latest -> savlatest
  535.     save_this                        \ Call before we clobber DP
  536.     dp    ['] dp -  -> dp                \ Here we make DP and LATEST relative
  537.     latest    ['] dp -  -> latest        \  to DP so we can set them up when
  538.                                     \  saved image is read in
  539.     purge                            \ Purge modules so saved image has them all
  540.                                     \  unloaded
  541.     write: ffcb                        \ Leave return code on stack for caller
  542.     savdp -> dp  savlatest -> latest
  543.     savetype savesig set: ffcb
  544.     close: ffcb drop
  545. \    type# 101 ( Saved: )  getname: ffcb  type  cr  ;
  546. ;
  547.  
  548. : SAVE        \ Takes name from input stream
  549.     setname: ffcb  (save)  ?error 105  ;
  550.  
  551.  
  552. : CL2        \ Next cleanup word - clean up all file stuff on abort,
  553.             \ as well as whatever we were doing before (in CL1).
  554.     clear: loadfile  close: ffcb drop
  555.     nomod  release: $lg1  release: $lg2
  556.     ['] null  -> logvec  false -> endload?
  557.     cl1  ;
  558.  
  559.  
  560. : FILINIT
  561.     ['] file  dup  ['] fFcb  4+  reloc!
  562.     fFcb 18 + @                    \ Name pointer - doc name may not be in fFcb
  563.     count  32 min  myDocName place
  564.     fFcb  make_obj
  565.     clear: loadfile  ;
  566.  
  567.  
  568. ' filinit      -> objinit
  569. ' cl2      -> abortvec
  570.